perm filename EULER[CAR,BGB] blob
sn#016004 filedate 1972-12-20 generic text, type T, neo UTF8
00100 TITLE EULER - EULER SURFACE PRIMITIVES - JULY 1972.
00200
00300 COMMENT /
00400 These primitives preserve the Euler Equation F-E+V = 2*B-2*H;
00500 which was named after Leonhard Euler,1707-1783, Swiss mathematician.
00600
00700 INVERT(E); "|" COMMAND.
00800 EVERT(B); "¬" COMMAND.
00900 VNEW ← MKEV(F,V); "E" COMMAND.
01000 ENEW ← MKFE(V1,F,V2); "J" COMMAND.
01100 VNEW ← ESPLIT(E); "M" COMMAND.
01200 F ← KLFE(ENEW); "K" COMMAND.
01300 E ← KLEV(VNEW); "K" COMMAND.
01400 V ← KLVE(ENEW); "αK" COMMAND.
01500 BNEW ← MKCOPY(B); "C" COMMAND.
01600 ENEW ← GLUEE(F1,V1,F2,V2); "J" COMMAND.
01700 /
01800
01900 ;THE EULER PRIMITVES ARE DEPENDENT ON THE WING OPERATIONS.
02000 EXTERN GETBLK,RELBLK
02100 EXTERN MKB,MKF,MKE,MKV,MKBFV
02200 EXTERN KLB,KLF,KLE,KLV,WING
02300 EXTERN WING
02400 EXTERN ECW,ECCW,OTHER,OTHER.
02500 EXTERN BODY,FCW,FCCW,VCW,VCCW
02600
02700 ;BIT FOR MARKING EDGES OF A WASP FACE'S WAIST.
02800 ↓WASP←←1B5
00100 SUBR(INVERT) ;AC-TRANSPARENT.
00200 BEGIN INVERT
00300 E←1
00400 DAC E,SAV#
00500 LAC E,ARG1
00600 FOR I⊂(1,3,4,5) {MOVSS I(E)↔}
00700 FOR I⊂(-3,-2,-1){MOVNS I(E)↔}
00800 LAC E,SAV
00900 POP1J
01000 BEND
01100
01200 ;EVERT(B) - TO TURN INSIDE OUT.
01300 SUBR(EVERT)
01400 BEGIN EVERT
01500 ACCUMULATORS{B,E}
01600 CDR B,ARG1
01700 TEST B,BBIT↔POP1J
01800 LAC E,B
01900 L1: PED E,E
02000 TEST E,EBIT↔GO L2
02100 MOVSS 1(E)
02200 MOVS 4(E)↔MOVS 1,5(E)
02300 DAC 1,4(E)↔DAC 5(E)
02400 GO L1
02500 ;...AND ALL THE PARTS OF THIS BODY.
02600 L2: PART 0,B↔JUMPL .+5
02700 PUSH P,B↔PUSH P,0↔PUSHJ P,EVERT↔POP P,B
02800 CDR (P)↔CAIE .-2↔POP1J
02900 COPART B,B↔SKIPL E,B↔GO L1↔POP1J
03000 BEND
00100 ;VNEW ← MKEV(F,V). "E" COMMAND.
00200 SUBR(MKEV)
00300 BEGIN MKEV
00400 ACCUMULATORS {VNEW,B,F,V,ENEW,E1,E2}
00500 ;CHECK FOR BAD ARGUMENTS.
00600 CDR VNEW,ARG1;FOR BAD RETURNS.
00700 LAC V,ARG1↔TEST(V,VBIT)↔POP2J
00800 LAC F,ARG2↔TEST(F,FBIT)↔POP2J
00900 NCNT 0,F↔SOSGE↔NCNT. 0,F;WIRE SWEEPING.
01000 ;CREATE A NEW EDGE AND VERTEX.
01100 SETQ(B,{BODY,V})
01200 SETQ(VNEW,{MKV,B})
01300 FOR @$ Qε{XYZ}{LAC Q$WC(V)↔DAC Q$WC(VNEW)↔}
01400 SETQ(ENEW,{MKE,B})
01500 ;MAKE FACE AND VERTEX LINKS.
01600 PED. ENEW,VNEW
01700 NFACE. F,ENEW
01800 PFACE. F,ENEW
01900 NVT. VNEW,ENEW
02000 PVT. V,ENEW
02100 ;CHECK FOR VERTEX BODY CASE.
02200 PED E1,F↔JUMPE E1,[
02300 PED. ENEW,F↔PED. ENEW,V
02400 PCW.. ENEW,ENEW↔NCCW.. ENEW,ENEW↔GO .+1]
02500 ;LOWER WINGS POINT AT SELF.
02600 NCW.. ENEW,ENEW
02700 PCCW.. ENEW,ENEW
02800 ;GET THE UPPER WINGS.
02900 PED E1,V↔LAC E2,E1
03000 NFACE 0,E1↔PFACE 1,E1
03100 CAMN 0,1↔GO L2
03200 L1: LAC E1,E2
03300 SETQ(E2,{ECW,E1,V})
03400 CALL FCW,E1,V
03500 CAME 1,F↔GO L1
03600 ;TIE ENEW TO ITS UPPER WINGS.
03700 L2: PCW.. E1,ENEW
03800 NCCW.. E2,ENEW
03900 PVT 0,E1↔CAME 0,V↔GO[PCCW.. ENEW,E1↔GO .+2]↔NCCW.. ENEW,E1
04000 PVT 0,E2↔CAME 0,V↔GO[NCW.. ENEW,E2↔GO .+2]↔PCW.. ENEW,E2
04100 LAC 1,VNEW↔POP2J
04200 LIT
04300 BEND
00100 ;ENEW ← MKFE(V1,F,V2); "J" COMMAND.
00200 SUBR(MKFE)
00300 BEGIN MKFE
00400 ACCUMULATORS{V1,F,V2,FNEW,ENEW,E,E0,B,S12,N}
00500
00600 ;FETCH THE ARGUMENTS.
00700 CDR V1,ARG3
00800 CDR F,ARG2
00900 CDR V2,ARG1
01000
01100 ;DO THE CREATIONS.
01200 SETQ(B,{BODY,F})
01300 SETQ(FNEW,{MKF,B})
01400 SETQ(ENEW,{MKE,B})
01500
01600 ;SET F'S CNT POSITIVE WHEN NECESSARY.
01700 NCNT 0,F↔JUMPG .+5
01800 SOS↔MOVMS↔NCNT. 0,F↔NCNT. 0,FNEW
01900
02000 ;LINK ENEW.
02100 PED. ENEW,F↔ PED. ENEW,FNEW
02200 PFACE. F,ENEW↔ NFACE. FNEW,ENEW
02300 PVT. V1,ENEW↔ NVT. V2,ENEW
02400
02500 ;GET THE UPPER WINGS.
02600 PED E,V1↔LAC E0,E↔MOVS 1(E)↔CAME 1(E)
02700 GO[L1: LAC E0,E↔ SETQ(E,{ECW,E0,V1})
02800 CALL FCW,E0,V1↔CAME 1,F↔GO L1↔GO .+1]
02900 DAC E0,E1#↔DAC E,E2#
03000
03100 ;GET THE LOWER WINGS.
03200 PED E,V2↔LAC E0,E↔MOVS 1(E)↔CAME 1(E)
03300 GO[L2: LAC E0,E↔ SETQ(E,{ECW,E0,V2})
03400 CALL FCW,E0,V2↔CAME 1,F↔GO L2↔GO .+1]
03500 DAC E0,E3#↔DAC E,E4#
00100 ;CDR V2'S TAIL REPLACING +F'S WITH FNEW.
00200 LACI N,1;PERIMETER COUNTER.
00300 LAC E,E3
00400 L3: MOVS 1,1(E)↔CAME 1,1(E)↔GO L4
00500 PFACE. FNEW,E
00600 AOS N↔PCW E,E↔GO L3
00700
00800 ;CCW FROM V1 REPLACING F'S WITH FNEW.
00900 L4: LAC E0,E↔LAC E,E2↔SETZM A#↔CAMN E0,E2↔GO L6
01000 L5: TESTZ E,WASP↔JSR WASPS
01100 NFACE 0,E
01200 CAME F,0
01300 GO[PFACE. FNEW,E↔GO .+2]
01400 NFACE. FNEW,E
01500 AOS N
01600 CAME E,E0
01700 GO[DAC E,A↔SETQ(E,{ECCW,E,FNEW})↔GO L5]
01800
01900 ;LINK THE WINGS.
02000 L6: CALL WING,E1,ENEW
02100 CALL WING,E2,ENEW
02200 CALL WING,E3,ENEW
02300 CALL WING,E4,ENEW
02400
02500 ;UPDATE PERIMETER COUNTS WHEN NECESSARY.
02600 NCNT 0,FNEW↔ JUMPN 0,L7↔ NCNT. N,FNEW
02700 NCNT 0,F↔ SUB 0,N↔ ADDI 2↔ NCNT. 0,F
02800 L7: LAC 1,ENEW↔POP3J
02900
03000 WASPS: 0
03100
03200 PCW 1,E↔CAMN 1,A↔GO W1
03300 PCCW 1,E↔CAME 1,A↔GO W2
03400
03500 W1: SETZM A↔MARKZ E,WASP↔PFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
03600 AOS N↔TESTZ E,WASP↔GO W1↔GO @WASPS
03700
03800 W2: SETZM A↔MARKZ E,WASP↔NFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
03900 AOS N↔TESTZ E,WASP↔GO W2↔GO @WASPS
04000
04100 LIT
04200 BEND
00100 ;VNEW ← ESPLIT(E); "M" COMMAND.
00200 SUBR(ESPLIT)
00300 BEGIN ESPLIT
00400 ACCUMULATORS{VNEW,ENEW,B,E,V}
00500
00600 ;CHECK FOR BAD ARGUMENTS.
00700 CDR VNEW,ARG1
00800 LAC E,VNEW
00900 TEST E,EBIT↔GO L
01000 PVT V,E
01100
01200 ;CREATE A NEW EDGE AND VERTEX.
01300 PBODY B,E
01400 SETQ(VNEW,{MKV,B})
01500 SETQ(ENEW,{MKE,B})
01600 SLACI AA(E)↔LAPI AA(ENEW)↔BLT CC(ENEW)
01700
01800 ;UPDATE V'S FIRST PTR WHEN NECESSARY.
01900 PED 0,V↔CAMN 0,E↔PED. ENEW,V
02000 ;PLACE VNEW BETWEEN E AND ENEW.
02100 PED. ENEW,VNEW
02200 PVT 0,E↔PVT. 0,ENEW
02300 PVT. VNEW,E
02400 NVT. VNEW,ENEW
02500 PFACE 0,E↔PFACE. 0,ENEW
02600 NFACE 0,E↔NFACE. 0,ENEW
02700
02800 ;NEW UPPER WINGS ARE LIKE THE OLDE;
02900 PCW 0,E↔CALL WING,0,ENEW
03000 NCCW 0,E↔CALL WING,0,ENEW
03100
03200 ;EDGES POINT AT EACH OTHER ACROSS VNEW.
03300 NCCW.. ENEW,E↔PCW.. ENEW,E
03400 NCW.. E,ENEW↔PCCW.. E,ENEW
03500 L: LAC 1,VNEW↔POP1J
03600 BEND
00100 ;F ← KLFE(ENEW); "K" COMMAND.
00200 SUBR(KLFE)
00300 BEGIN KLFE
00400 ACCUMULATORS{ENEW,FNEW,V1,V2,E1,E2,E3,E4,S12,E,F,B}
00500
00600 ;PICK THINGS UP.
00700 CDR ENEW,ARG1
00800 PFACE F,ENEW↔ NFACE FNEW,ENEW
00900 PVT V1,ENEW↔ NVT V2,ENEW
01000 ;GET THE WINGS.
01100 PCW E1,ENEW
01200 NCCW E2,ENEW
01300 NCW E3,ENEW
01400 PCCW E4,ENEW
01500 ;GET RID OF ENEW APPEARANCES IN F & V.
01600 PED 0,V1↔ CAMN 0,ENEW↔ PED. E1,V1
01700 PED 0,V2↔ CAMN 0,ENEW↔ PED. E3,V2
01800 PED 0,F ↔ CAMN 0,ENEW↔ PED. E3,F
01900 ;GET RID OF FNEW APPEARANCES
02000 LAC E,E2
02100 L1: PFACE 0,E↔CAMN 0,FNEW↔GO[PFACE. F,E↔GO L2]
02200 NFACE 0,E↔CAMN 0,FNEW↔GO[NFACE. F,E↔GO L2]
02300 FATAL(KLFE)
02400 L2: CAME E,E3↔GO[SETQ(E,{ECCW,E,F})↔GO L1]
02500 ;LINK WINGS TOGETHER ABOUT F.
02600 CALL WING,E2,E1
02700 CALL WING,E4,E3
02800 ;GET RID OF FNEW AND ENEW.
02900 PBODY B,ENEW
03000 CALL KLF,B,FNEW
03100 CALL KLE,B,ENEW
03200 LAC 1,F
03250 POP1J
03300 BEND
00100 ;E ← KLEV(VNEW); "K" COMMAND.
00200 SUBR(KLEV)
00300 BEGIN KLEV
00400 ACCUMULATORS{E,ENEW,V,VNEW,F,B}
00500 CDR VNEW,ARG1↔PED ENEW,VNEW
00600 SETQ(E,{ECCW,ENEW,VNEW})
00700 CALL ECCW,E,VNEW↔CAME 1,ENEW
00800 GO[CALL KLFE,1↔GO KLEV]
00900
01000 ;ORIENT EDGES AS IN MANDALA.
01100 NVT 0,ENEW↔ CAMN 0,VNEW↔ GO .+3↔ CALL INVERT,ENEW
01200 PVT 0,E↔ CAMN 0,VNEW↔ GO .+3↔ CALL INVERT,E
01300 ;TIE E TO ITS NEW VERTEX.
01400 PVT V,ENEW↔ PVT. V,E
01500 ;MAKE E'S UPPER WINGS LIKE ENEW'S.
01600 PCW 0,ENEW↔ CALL WING,0,E
01700 NCCW 0,ENEW↔ CALL WING,0,E
01800
01900 ;ELIMINATE OCCURENCES OF ENEW IN F & V.
02000 PED 0,V↔ CAMN 0,ENEW↔ PED. E,V
02100 PFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
02200 NFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
02300 ;PURGE 'EM.
02400 PBODY B,ENEW
02500 CALL KLV,B,VNEW
02600 CALL KLE,B,ENEW
02700 LAC 1,E↔POP1J
02800 LIT
02900 BEND
03000 COMMENT . \ pvt / KLEV MANDALA
03100 \ /
03200 nccw \ / pcw
03300 \ /
03400 V ⊗
03500 |
03600 ENEW |
03700 | nvt
03800 VNEW ⊗
03900 | pvt
04000 E |
04100 |
04200 ⊗
04300 / \
04400 ncw / \ pccw
04500 / \
04600 / nvt \.
00100 ; V ← KLVE(E) - KILL E & NVT(E) RETURNING PVT(E).
00200 SUBR(KLVE)
00300 BEGIN KLVE
00400 ACCUMULATORS{A,E,E1,E2,E3,E4,V1,V2,S12}
00500
00600 ;PICK THINGS UP.
00700 CDR E,ARG1↔NVT V1,E↔PVT V2,E
00800 PCW E1,E↔NCCW E2,E↔NCW E3,E↔PCCW E4,E
00900
01000 ;REPLACE FACE-VERTEX PED'S THAT MIGHT CONTAIN E.
01100 PFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E1,1
01200 NFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E2,1
01300 PED 0,V2↔CAMN 0,E↔PED. E2,V2
01400
01500 ;REPLACE V1 WITH V2.
01600 LAC A,E3
01700 L1: PVT 1,A↔CAME 1,V1↔GO[NVT. V2,A↔GO .+2]↔PVT. V2,A
01800 SETQ(A,{ECCW,A,V2})
01900 CAME A,E↔GO L1
02000
02100 ;SPLICE WINGS TOGETHER.
02200 CALL WING,E1,E4
02300 CALL WING,E2,E3
02400
02500 ;BURN THE GARBAGE.
02600 PBODY A,E
02700 CALL KLE,A,E
02800 CALL KLV,A,V1
02900 LAC 1,V2
03000 POP1J
03100 LIT
03200 BEND
03300 COMMENT . KLVE MANDALA
03400 E2 \ / E1
03500 nccw \ / pcw
03600 \ /
03700 pvt ⊗ V2
03800 |
03900 | E
04000 |
04100 nvt ⊗ V1
04200 / \
04300 ncw / \ pccw
04400 E3 / \ E4.
00100 ;BNEW ← MKCOPY(B).
00200 SUBR(MKCOPY)
00300 BEGIN MKCOPY
00400 ACCUMULATORS{B,F,E,V,BNEW,Q,A}
00500 EXTERN WORLD;
00600 LAC B,ARG1
00700 TEST B,BBIT↔POP1J↔SETQ(BNEW,{MKB,WORLD})
00800 LAC B,ARG1↔LAC F,B↔LAC E,B↔LAC V,B
00900
01000 ;FOREACH E|BE⊗B≡E DO.
01100 L1: PED E,E↔TEST E,EBIT↔GO L2
01200 ALT A,E↔JUMPE A,.+6
01300 SUBI A,3↔LACI 12↔DIP (A)↔PUSH P,A↔PUSHJ RELBLK
01400 SETQ(Q,{MKE,BNEW})↔ALT. Q,E↔GO L1
01500
01600 ;FOREACH F|BF⊗B≡F DO.
01700 L2: PFACE F,F↔TEST F,FBIT↔GO L3
01800 SETQ(Q,{MKF,BNEW})↔ALT. Q,F
01900 PED A,F↔ALT A,A↔PED. A,Q
02000 LAC QQ(F)↔DAC QQ(Q)↔GO L2
02100
02200 ;FOREACH V|BV⊗B≡V DO.
02300 L3: PVT V,V↔TEST V,VBIT↔GO L4
02400 SETQ(Q,{MKV,BNEW})↔ALT. Q,V
02500 PED A,V↔ALT A,A↔PED. A,Q
02600 SLACI XWC(V)↔LAPI XWC(Q)↔BLT ZWC(Q)↔GO L3
02700
02800 ;FOREACH E|BE⊗B≡E DO
02900 L4: PED E,E↔TEST E,EBIT↔GO L5
03000 ALT Q,E
03100 PVT V,E↔ ALT V,V↔PVT. V,Q
03200 NVT V,E↔ ALT V,V↔NVT. V,Q
03300 PFACE F,E↔ALT F,F↔PFACE. F,Q
03400 NFACE F,E↔ALT F,F↔NFACE. F,Q
03500 NCW A,E↔ ALT A,A↔NCW.. A,Q
03600 PCW A,E↔ ALT A,A↔PCW.. A,Q
03700 NCCW A,E↔ ALT A,A↔NCCW.. A,Q
03800 PCCW A,E↔ ALT A,A↔PCCW.. A,Q
03900 GO L4
04000 L5: SETZ↔LAC 1,BNEW↔LAC E,ARG1
04100 L6: PED E,E↔TEST E,EBIT↔POP1J
04200 ALT. 0,E↔GO L6
04300 BEND
00100 ;ENEW ← GLUEE(F1,V1,F2,V2) - LIKE TWO MKEV(F,V)'S BACK TO BACK.
00200 SUBR(GLUEE)
00300 BEGIN GLUEE
00400 Q←1
00500 ACCUMULATORS{F1,V1,F2,V2,B,E,E1,E2,E3,E4}
00600 CDR F1,ARG4↔CDR V1,ARG3
00700 CDR F2,ARG2↔CDR V2,ARG1
00800 ;BODY SPLICING.
00900 PED E,F1↔PBODY B,E
01000 PED E,F2
01100
01200 ;REPLACE F2 WITH F1.
01300 PED E,F2↔DAC E,E0#
01400 L1: PFACE Q,E↔CAMN Q,F2↔PFACE. F1,E
01500 NFACE Q,E↔CAMN Q,F2↔NFACE. F1,E
01600 SETQ(E,{ECCW,E,F1})
01700 CAME E,E0↔GO L1
01800 CALL KLF,B,F2
01900
02000 ;EDGE CREATION
02100 SETQ(E,{MKE,B})
02200 MARK E,WASP
02300 NFACE. F1,E↔PFACE. F1,E
02400 NVT. V1,E↔PVT. V2,E
02500
02600 ;MAKE WINGS
02700 SETQ(E1,{ECW,V2,F1})↔PCW.. E1,E
02800 SETQ(E2,{ECW,E1,V2})↔NCCW.. E2,E
02900 SETQ(E3,{ECW,V1,F1})↔NCW.. E3,E
03000 SETQ(E4,{ECW,E3,V1})↔PCCW.. E4,E
03100
03200 PVT Q,E1↔CAME Q,V2↔GO[PCCW.. E,E1↔GO .+2]↔NCCW.. E,E1
03300 PVT Q,E2↔CAME Q,V2↔GO[NCW.. E,E2↔GO .+2]↔PCW.. E,E2
03400 PVT Q,E3↔CAME Q,V1↔GO[PCCW.. E,E3↔GO .+2]↔NCCW.. E,E3
03500 PVT Q,E4↔CAME Q,V1↔GO[NCW.. E,E4↔GO .+2]↔PCW.. E,E4
03600
03700 ;MARK WASP WAIST ON POTENTIAL SPUR STARTING AT V1.
03800 CAME E1,E2↔GO L2
03900 MARK E1,WASP↔PVT V1,E1↔PED E1,V1
04000 MOVS Q,1(E1)↔CAMN Q,1(E1)↔GO .-5
04100
04200 L2: LAC Q,E↔CALL INVERT,Q↔POP4J
04300 LIT
04400 BEND
04500
04600
04700 END
04800 EULER.FAI - EOF.